;;########################################################################
;; clusplg1.lsp
;; Copyright (c) 1999-2000 by Chad Petty & Forrest Young
;; Continuation of ViSta Plugin for Cluster Analysis.
;; Adapted from freqplg1.lsp by Chad Petty
;;########################################################################
;; $Id: clusplg1.lsp,v 1.1.1.1 2002/05/17 20:57:41 uluru Exp $

; PLUGIN STEP 3: DEFPROTO
  
(defproto clus-plugin-object-proto 
; instance slots
  '(linkage proximity dendro container permuted-datamat permuted-labels cluster-model point-color)
; shared slots
   () 
; parents
   analysis-plugin-object-proto)
  
;; PLUGIN STEP 4: ISNEW
;;
;; The plugin's :isnew method MUST have exactly the same call-next-method
;; as is used below. You cannot add or remove arguments.

(defmeth clus-plugin-object-proto :isnew 
  (linkage proximity
   menu-item-title tool-name model-prefix ok-data-types 
   data title name dialog ok-variable-types)

  (if (not (equal data *current-data*))
      (setcd data))
  
  (when (not (equal (send data :data-type) "multivariate"))
	(fatal-message "Cluster data must be multivariate"))
  
  (send self :linkage   linkage)
  (send self :proximity proximity)
  (send self :dendro nil)

  (call-next-method 
   menu-item-title tool-name model-prefix ok-data-types 
   data title name dialog ok-variable-types)
  
  )
  
; PLUGIN STEP 5: SLOT ACCESSORS

(defmeth clus-plugin-object-proto :proximity
  (&optional (string nil set))
; list defined in Proximity.lsp
"Distance measure: Euclidean, Std-euclidean, Sq-euclidean, Cityblock, Mahalanobis, Cosine, Correlation"
  (if set (setf (slot-value 'proximity) string))
  (slot-value 'proximity)
  )
(defmeth clus-plugin-object-proto :container (&optional (obj nil set))
  (if set (setf (slot-value 'container) obj))
  (slot-value 'container))
  
(defmeth clus-plugin-object-proto :linkage
  (&optional (string nil set))
; list defined in DendroFunctions.lsp
"Algorithm linkage: average, centroid, ward, gower, weighted, single, complete"
  (if set (setf (slot-value 'linkage) string))
  (slot-value 'linkage)
)

(defmeth clus-plugin-object-proto :cluster-model
  (&optional (dat nil set))
 "Cluster Model object"
  (if set (setf (slot-value 'cluster-model) dat))
  (slot-value 'cluster-model)
)

(defmeth clus-plugin-object-proto :dendro
  (&optional (dat nil set))
 "Dendrogram object"
  (if set (setf (slot-value 'dendro) dat))
  (slot-value 'dendro)
)

(defmeth clus-plugin-object-proto :permuted-datamat
  (&optional (mat nil set))
 "Data permuted in optimal order"
  (if set (setf (slot-value 'permuted-datamat) mat))
  (slot-value 'permuted-datamat)
)

(defmeth clus-plugin-object-proto :permuted-labels
  (&optional (labels nil set))
 "Labels permuted according to data permutation"
  (if set (setf (slot-value 'permuted-labels) labels))
  (slot-value 'permuted-labels)
)

(defmeth clus-plugin-object-proto :point-color
  (&optional (colors nil set))
 "Point colors of the spreapdlot"
  (if set (setf (slot-value 'point-color) colors))
  (slot-value 'point-color)
)
  
; PLUGIN STEP 6: OPTIONS METHOD ----------------------------------------

(defmeth clus-plugin-object-proto :options ()
"Args: none
This method constructs and displays the options dialog window for 
cluster analysis when a dialog box is requested and needed. The method 
places appropriate information into slots. Returns nil when dialog 
canceled or when no table variables are selected, returns t otherwise."

(let* (
       (methlist '("average" "centroid" "ward" "gower" "weighted" 
		   "single" "complete"))
       (methnum (choose-item-dialog "Merge method:" methlist)) 
       (proxlist '("Euclidean" "Std-euclidean" "Sq-euclidean" "Cityblock" 
		   "Mahalanobis" "Cosine" "Correlation"))
       (proxnum (choose-item-dialog "Proximity measure:" proxlist))
       (rc (if (and methnum proxnum) t nil))
       )
  (if methnum
      (send self :linkage (select methlist methnum))
    )
  (if proxnum
      (send self :proximity (select proxlist proxnum))
    )
  rc
  )
)

#|
(defun dialog-box ()
  (let* ((m-label  (send text-item-proto   :new "Merge"))
         (p-label  (send text-item-proto   :new "Proximity"))
         (m-item (send choice-item-proto :new 
                       (list "average"  "centroid"  "ward"  "gower"  "weighted"  "single"  "complete")))
         (p-item (send choice-item-proto :new 
                       (list "Euclidean" "Std-Euclidean"  "Sq-Euclidean"  "Cityblock"  "Mahalanobis"  "Cosine" "Correlation")))
         (cancel   (send modal-button-proto :new "Cancel"))
         (ok       (send modal-button-proto :new "OK" 
                         :action #' (lambda () 
                                      (send self :collect-values))))
         (the-dialog (send modal-dialog-proto :new
                           (list 
                            (list (list m-label m-item)
                                  (list p-label p-item))
                            (list ok cancel))
                           :default-button ok))
         )
    (defmeth ok :collect-values ()
      (list (send m-item :value)
            (send p-item :value)))
    (send the-dialog :modal-dialog)))
|#

;the next files have to be loaded after the defproto statement
;since they involve defining methods used the prototype
;they must also be loaded before they are needed 
;in the visualization and analysis methods

(load  (strcat *clus-plugin-path* "dendrogram"))
(load  (strcat *clus-plugin-path* "imdisp"))
;(load (strcat *clus-plugin-path* "guidtour"))

; PLUGIN STEP 7: ANALYSIS METHOD

(defmeth clus-plugin-object-proto :analysis ()
  (let* ((datamat (send self :active-data-matrix '(numeric)))
         (nrow (array-dimension datamat 0))
         (ncol (array-dimension datamat 1))
         (datalist (mapcar #'(lambda (x) (coerce x 'list)) (row-list datamat)))
         (obslabs (send self :active-labels))
         (proximity (send self :proximity))
         (linkage (send self :linkage))
         (cluster-model 
          (send self :cluster-model
                (cluster-model datalist :linkage linkage :proximity proximity
                               :iteration-plot t)))
        ; (prxmat (send cluster-model :prxmat))
        ; (eigvec1 (send self :eigvec-of-double-center prxmat))
        ; (allmat (bind-columns obslabs datamat))
        ; (result (sort-and-permute eigvec1 allmat))
        ; (permuted-labels (col result 0))
        ; (permuted-datamat (select result (iseq nrow) (iseq 1 (1- ncol))))
         )

    (send self :permuted-datamat datamat)
    (send self :permuted-labels obslabs)))

(defmeth clus-plugin-object-proto :eigvec-of-double-center (mat)
  (let* ((rmeans (mapcar #'mean (row-list mat)))
         (nrows (length rmeans))
         (meanmat (matrix (list nrows nrows) (repeat rmeans nrows)))
         (dblcntrd (- mat meanmat (transpose meanmat) (- (mean meanmat)))))
    (first (eigenvectors dblcntrd))))

; PLUGIN STEP 8: REPORT METHOD

(defmeth clus-plugin-object-proto :report (&key (dialog nil))
  (let* ((w 
          (report-header (send self :title) :page t))
         (proximity (send self :proximity))
         (linkage (send self :linkage))
         (prxmat (send (send self :cluster-model) :prxmat))
         (numobj (first (array-dimensions prxmat)))
         (labels (send self :permuted-labels))
         )
    (display-string 
     (format nil "Cluster Analysis: ~a Data~%"
             (send (send self :data-object) :name)) w)
    (display-string
     (format nil "~%Number of Objects:     ~d" numobj) w)
    (display-string
     (format nil "~%Linkage:     ~d" linkage) w)
        (display-string
     (format nil "~%Proximity:     ~d" proximity) w)
    (print-matrix-to-window prxmat w :row-labels labels :column-labels labels :row-heading 'nil :column-heading "Distances among objects")
    (send w :fit-window-to-text)))
; PLUGIN STEP 8: CREATE DATA

(defmeth clus-plugin-object-proto :create-data 
  (&key (dialog nil)
        (observed nil)
        (expected nil)
        (residuals nil)
        (all t))
"Args: DIALOG (observed t) (expected t)
Creates output data objects. If DIALOG=T then presents dialog to determine which objects created. Otherwise presents specified objects. If no options, specified, creates observed and expected."
  (if (not (eq current-object self)) (setcm self)) 
  (let* ((creator (send *desktop* :selected-icon))
         (cluster-model (send self :cluster-model))
         (dendro-plot (send self :dendro))
         (clusterlist (send dendro-plot :clusterlist))
         (correct-order (select (combine clusterlist)
                                (which (mapcar #'(lambda (x) (integerp x)) 
                                              (combine clusterlist)))))
         (permuted-datamat (apply 'bind-rows (select (row-list (send self :permuted-datamat)) correct-order)))
         (vars (combine "ClusterColors" "ObsIndex" (send self :active-variables '(numeric)) ))
         (labels (select (send self :permuted-labels) correct-order))
         (numnum (1+ (length vars)))
         (colors (send dendro-plot :point-color (iseq (first (array-dimensions permuted-datamat)))))
         

         (data (data (send self :name)
          :created creator
          :creator-object self
          :title (send self :title)
          :data (combine (apply 'bind-columns (append (list colors) (list correct-order) (column-list permuted-datamat) )))
          :variables vars
          :labels labels
          :types (combine "Category" (repeat "Numeric" numnum))))
         )
    (send (send data :linked-graph) :point-color (iseq (first (array-dimensions permuted-datamat))) colors)
    (send (send data :linked-graph) :redraw)
    ))

; PLUGIN STEP 9: VISUALIZATION METHOD



(defmeth clus-plugin-object-proto :visualize (&key dialog)
  (let* ((cluster-model (send self :cluster-model))
         (clus-plugin self)
       	 (linkage (send self :linkage))
       	 (proximity (send self :proximity))
         (permuted-point-labels (coerce (send self :permuted-labels) 'list ))
         (dendro-plot (dendrogram-vis cluster-model :title "Cluster Plot"
                      :labels permuted-point-labels 
                      :linkage linkage :proximity proximity))
         (correct-order (select (combine (send dendro-plot :clusterlist))
                                (which (mapcar #'(lambda (x) (integerp x)) 
                                               (combine (send dendro-plot :clusterlist))))))
         (permuted-datamat (apply 'bind-rows (select (send cluster-model :data) correct-order)))
    
         (var-labels (send self :active-variables '(numeric)))
         (permuted-variables (column-list permuted-datamat))
         (svd (sv-decomp (normalize permuted-datamat)))
         (scores (matmult (first svd) (diagonal (sqrt (second svd)))))
         (ndims (min 9 (array-dimension scores 1)))
         (score-vars (select (column-list scores) (iseq ndims)))
         (dimlabs (mapcar #'(lambda(i)(format nil "PC~d" i))(iseq ndims)))
         (bxplot (boxplot permuted-variables 
                          :point-labels permuted-point-labels
                          :variable-labels (send self :variables) :connect-points t :equate t))
         (pointplot (scatterplot-matrix permuted-variables 
                               :point-labels permuted-point-labels
                               :variable-labels var-labels
                          ))
         (datalist (mapcar #'(lambda (x) (coerce x 'list)) 
               			  (row-list permuted-datamat)))
         (name-list (name-list (send dendro-plot :slot-value 'symbol)))

; :labels permuted-point-labels
         (prxmat (send cluster-model :prxmat))
         (prxmeans (mapcar #'mean (row-list prxmat)))
         (nrows (length prxmeans))
         (prxmeanmat (matrix (list nrows nrows) (repeat prxmeans nrows)))
         (prxdblcntrd (- prxmat prxmeanmat (transpose prxmeanmat) (- (mean prxmeanmat))))
         (dblcnt-prxmat-color-plot (newdisp prxdblcntrd))

        ; (rmat (correlation-matrix (transpose permuted-datamat)))
        ; (rmeans (mapcar #'mean (row-list rmat)))
        ; (nrows (length rmeans))
        ; (meanmat (matrix (list nrows nrows) (repeat rmeans nrows)))
        ; (dblcntrd (- rmat meanmat (transpose meanmat) (- (mean meanmat))))
        ; (dblcnt-corr-permuted-color-plot (newdisp dblcntrd))
         
         

	 (splot (spreadplot (matrix '(2 4) 
                             (list  bxplot
                                    nil
                                    pointplot
                                    name-list
                                    dendro-plot
                                    nil
                                    nil
                                    nil
                                     ))
                        :span-right (matrix '(2 4) '(2 0 1 1 3 0 0 0))
                     :span-down (matrix '(2 4) '(1 1 1 2 1 1 1 0))
                                         
                     )))
    (send self :dendro dendro-plot)
    
    (send pointplot :point-color (iseq nrows) 'blue)
    (send name-list :point-color (iseq nrows) 'blue)
  (send bxplot :connect-points t)
  (send bxplot :enable-connect-points t)
    (send pointplot :point-label (iseq (length permuted-point-labels)) (send dendro-plot :slot-value 'symbol))
    (send dendro-plot :add-points (list (iseq 1 nrows) (repeat 0 nrows))
          :point-labels (send dendro-plot :slot-value 'symbol) :point-colors (repeat 'blue nrows))
    (send pointplot :plot-buttons :x nil :y nil)
    (send dendro-plot :plot-buttons)
    (defmeth dendro-plot :ask-save-pdf ()
      (send self (save-pdf-sc self)))
    (send bxplot :linked t)
    (send dendro-plot :linked t)
    (send pointplot :linked t)
    (send name-list :linked t)
    (send splot :show-spreadplot)
    splot))



(provide "clusplg1")